home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / bcomp / undefined.scm < prev    next >
Text File  |  1995-10-13  |  2KB  |  57 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3. ; Added really-noting-undefined-variables proc, which gives you noise control.
  4. ;     -Olin 6/95.
  5.  
  6.  
  7. ; Maintain and display a list of undefined names.
  8.  
  9. (define $note-undefined (make-fluid #f))
  10.  
  11. (define (note-undefined! p name)
  12.   (let ((note (fluid $note-undefined)))
  13.     (if note (note p name))))
  14.  
  15. (define (noting-undefined-variables p thunk)
  16.   (really-noting-undefined-variables p (current-output-port) thunk))
  17.  
  18. (define (really-noting-undefined-variables p noise thunk)
  19.   (let* ((losers '())
  20.      (foo (lambda (env name)
  21.         (let ((probe (assq env losers)))
  22.           (if probe
  23.               (if (not (member name (cdr probe)))
  24.               (set-cdr! probe (cons name (cdr probe))))
  25.               (set! losers (cons (list env name) losers)))))))
  26.  
  27.     (let-fluid $note-undefined (lambda (p name)
  28.                  (if (generated? name)
  29.                      (foo (generated-env name)
  30.                       (generated-symbol name))
  31.                      (foo p name)))
  32.       (lambda ()
  33.     (dynamic-wind
  34.       (lambda () #f)
  35.       thunk
  36.       (lambda ()
  37.         (for-each (lambda (p+names)
  38.             (let* ((env (car p+names))
  39.                    ;; Keep the ones that are still unbound:
  40.                    (names (filter (lambda (nm)
  41.                         (unbound? (generic-lookup env nm)))
  42.                           (cdr p+names))))
  43.               (cond ((and (not (null? names)) noise)
  44.                  (display "Undefined" noise)
  45.                  (if (and p (not (eq? env p)))
  46.                      (begin (display " in " noise)
  47.                         (write (car p+names) noise)))
  48.                  (display ": " noise)
  49.                  (write (map (lambda (name)
  50.                            (if (generated? name)
  51.                            (generated-symbol name)
  52.                            name))
  53.                          (reverse names))
  54.                     noise)
  55.                  (newline noise)))))
  56.               losers)))))))
  57.